'This software was produced for the U. S. Government
'under Contract No. FA8721-09-C-0002, and is
'subject to the Rights in Noncommercial Computer Software
'and Noncommercial Computer Software Documentation Clause
'(DFARS) 252.227-7014 (JUN 1995)

'copyright 2009 The MITRE Corporation. All Rights Reserved.

Attribute VB_Name = "CopyRMAToSPT"
Option Explicit

Function SPTProfileExists() As Boolean
    Dim project As IRPProject
    Dim profile As RPProfile
    Dim blnFound As Boolean
    
    Set project = getProject
    blnFound = False
    For Each profile In project.profiles
        If profile.name = "SPT" Then
            blnFound = True
            Exit For
        End If
    Next

    SPTProfileExists = blnFound
End Function

Public Function AddReference() As Boolean
    Dim blnResult As Boolean
    
    blnResult = SPTProfileExists()
    If Not blnResult Then
        'Call addToModelByReference("C:\Program Files\Telelogic\Rhapsody 7.1\Share\Profiles\SPT\SPT.rpy")
        Call addToModelByReference("C:\Program Files\Telelogic\Rhapsody 7.2\Share\Profiles\SPT\SPT_rpy\SPT.sbs")
        blnResult = SPTProfileExists()
        If Not blnResult Then
            Call addToModelByReference("C:\Program Files\Telelogic\Rhapsody 7.1\Share\Profiles\SPT\SPT_rpy\SPT.sbs")
            blnResult = SPTProfileExists()
        End If
        If Not blnResult Then
            MsgBox "Unable to add SPT profile to project. Please try it manually and then re-run macro."
        End If
    End If
    AddReference = blnResult
End Function

Public Sub CopyRMAToSPT()
    Dim project As IRPProject
    Dim profile As RPProfile
    Dim components As New VBA.collection
    
    Set project = getProject

    'Call addToModelByReference("C:\Program Files\Telelogic\Rhapsody 7.1\Share\Profiles\SPT\SPT.rpy")
    If Not AddReference() Then
        Exit Sub
    End If
        
    Call BuildComponentList(project, components)
    Call CopyAllCollaborations(project, components)
    MsgBox "Done"
End Sub

Private Sub BuildComponentList(ByRef package As IRPPackage, ByRef components As collection)
    Dim subelements As IRPCollection
    Dim subelement As IRPModelElement

    Set subelements = package.getNestedElements
    For Each subelement In subelements
        If (subelement.metaClass = "Component") Then
            components.Add subelement
        End If
        If (subelement.metaClass = "Package") Then
            Call BuildComponentList(subelement, components)
        End If
    Next
End Sub

Private Sub CopyAllCollaborations(ByRef package As IRPPackage, ByRef components As collection)
    Dim subelements As IRPCollection
    Dim subelement As IRPModelElement
    
    Set subelements = package.getNestedElements
    For Each subelement In subelements
        If (subelement.metaClass = "SequenceDiagram") Then
            Call CopyCollaboration(subelement.getLogicalCollaboration, subelement, components)
        End If
        If (subelement.metaClass = "CollaborationDiagram") Then
            Call CopyCollaboration(subelement.getLogicalCollaboration, subelement, components)
        End If
        If (subelement.metaClass = "Package") Then
            Call CopyAllCollaborations(subelement, components)
        End If
    Next
End Sub

Private Function ConvertTimeValueToUS(val As String) As Double
    Dim i As Integer
    Dim result As Double
    Dim units As String, numStr As String
    
    ConvertTimeValueToUS = 0
    If Len(val) = 0 Then Exit Function

    i = InStr(1, val, ",")
    numStr = Trim$(Mid$(val, 2, i - 2))
    units = Trim$(Mid$(val, i + 1, Len(val) - (i + 2)))
    units = Mid$(units, 2)
    result = CDbl(numStr)
    If (units = "s" Or units = "secs") Then
        result = result * 1000000
    ElseIf (units = "ms") Then
        result = result * 1000
    ElseIf (units = "us") Then
    Else
        result = 0
    End If
    ConvertTimeValueToUS = result
End Function

Private Sub Push(ByRef pStack As collection, ByRef pObject As Object)
    If pStack.Count = 0 Then
        pStack.Add pObject
    Else
        pStack.Add pObject, , 1
    End If
End Sub

Private Function Pop(ByRef pStack As collection) As Object
    Dim result As Object
    Set result = pStack.item(1)
    Call pStack.Remove(1)
    Set Pop = result
End Function

Private Function IsStackEmpty(ByRef pStack As collection) As Boolean
    IsStackEmpty = (pStack.Count = 0)
End Function

Private Function GetPropertyValue(ByRef pModelElement As RPModelElement, pPropertyName As String) As String
    Dim val As String
    On Error Resume Next
    val = ""
    val = pModelElement.GetPropertyValue(pPropertyName)
    On Error GoTo 0
    GetPropertyValue = val
End Function

Private Function GetStereotype(pProfileName As String, pProfilePackageName As String, pStereotypeName As String) As RPStereotype
    Dim project As IRPProject
    Dim profile As RPProfile
    Dim stereotype As RPStereotype
    Dim package As RPPackage
    
    Set project = getProject
    For Each profile In project.profiles
        If UCase$(profile.name) = UCase$(pProfileName) Then
            For Each package In profile.packages
                If UCase$(package.name) = UCase$(pProfilePackageName) Then
                    For Each stereotype In package.userDefinedStereotypes
                        If stereotype.name = pStereotypeName Then
                            Set GetStereotype = stereotype
                            Exit Function
                        End If
                    Next
                End If
            Next
        End If
    Next
    Set GetStereotype = Nothing
End Function


Private Sub SetUMLTag(ByRef pModelElement As RPModelElement, pProfilePackageName As String, pStereotypeName As String, pTagName As String, pValue As String)
    Dim tag As RPTag
    Dim stereotype As RPStereotype
    
    ' add stereotype
    Set stereotype = GetStereotype("SPT", pProfilePackageName, pStereotypeName)
    
    If stereotype Is Nothing Then
        MsgBox "Stereotype " & pStereotypeName & " in package " & pProfilePackageName & " not found."
        Exit Sub
    End If
    
    'Call pModelElement.stereotypes.addItem(stereotype)
    'Call pModelElement.addStereotype(stereotype.name, pModelElement.metaClass)
    pModelElement.stereotype = stereotype
    
    ' set tag
    Set tag = pModelElement.getTag(pTagName)
    If tag Is Nothing Then
        MsgBox "tag " & pTagName & " under stereotype " & pStereotypeName & " not found"
    Else
        Call pModelElement.setTagValue(tag, pValue)
    End If
End Sub


    ' go through each message in collaboration
    ' current message is the message we are on in our loop through all of them
    ' executing message is the message whose duration is currently being summed up
    
    ' for each message, we do the following (current message or it is the one we are on in this loop)
    '   if current message initiates from executing message's execution lifeline then
    '       store executing message (if one) at beginning of executing message stack
    '   else
    '       repeat
    '         update SPT on executing message's UML counterpart based on its total duration (if zero, use calculated duration)
    '         if the executing message stack is not empty
    '           add executing message's total duration (if zero, use calculated) to the top executing message (if one) in the executing message stack
    '           set executing message to top one from executing message stack
    '         end if
    '       until current message initiates from executing message's execution lifeline
    '       store executing message at beginning of executing message stack
    '   end if
    '   create new executing message for the current message
    '   if current message has an overall duration:
    '     set executing message's total duration
    '   end if
    '   if current message has a local duration
    '     set executing message's local duration
    '     initialize executing message's calculated duration to local duration
    '   else
    '     set executing message's local duration to zero
    '     initialize executing message's calculated duration to zero
    '   end if
    ' next
    ' // finish unwinding stack completing messages
    '       repeat
    '         update SPT on executing message's UML counterpart based on its total duration (if zero, use calculated duration)
    '         if the executing message stack is not empty
    '           add executing message's total duration (if zero, use calculated) to the top executing message (if one) in the executing message stack
    '           set executing message to top one from executing message stack
    '         end if
    '       until current message initiates from executing message's execution lifeline

Private Sub CopyCollaboration(ByRef collaboration As IRPCollaboration, ByRef diagram As IRPDiagram, ByRef components As collection)
    Dim role As IRPClassifierRole, val As String
    Dim op As RPOperation
    Dim schedPolicy As String
    Dim strErrorBuffer As String
    Dim component As RPComponent
        
    strErrorBuffer = ""
    For Each role In collaboration.classifier
        ' doing all this on the classifier and not the lifeline b/c RapidRMA does not support the properties on the lifeline
        val = GetPropertyValue(role.formalClassifier, "SAResource.Class.SAExecutionEngine")
        If Len(val) > 0 Then
            Call SetUMLTag(role.formalClassifier, "RTschedulabilityModeling", "SAScheduler", "SAExecutionEngine", val)
            schedPolicy = ""
            For Each component In components
                If component.name = val Then
                    schedPolicy = GetPropertyValue(component, "SAEngine.Model.SASchedulingPolicy")
                End If
            Next
            If Len(schedPolicy) > 0 Then
                Call SetUMLTag(role.formalClassifier, "RTschedulabilityModeling", "SAScheduler", "SAschedulingPolicy", schedPolicy)
            End If
        End If
        If Not role.formalClassifier Is Nothing Then
            For Each op In role.formalClassifier.operations

                'duration
                val = GetPropertyValue(op, "Local::SAAction.Event.RTduration")
                If Len(val) = 0 Then
                    val = GetPropertyValue(op, "Local::SAAction.Operation.RTduration")
                End If
                If Len(val) = 0 Then
                    val = GetPropertyValue(op, "Local::SAAction.Class.RTduration")
                End If
                If Len(val) > 0 Then
                    Call SetUMLTag(op, "RTtimeModeling", "RTAction", "RTduration", val)
                End If

                'interarrival time
                val = GetPropertyValue(op, "SATrigger.Event.SAOccurrencePattern")
                If Len(val) = 0 Then
                    val = GetPropertyValue(op, "SATrigger.Class.SAOccurrencePattern")
                End If
                If Len(val) > 0 Then
                    Call SetUMLTag(op, "RTschedulabilityModeling", "SATrigger", "SAoccurrence", val)
                End If
            Next
        End If
    Next
    
    Call CopyMessages(collaboration, strErrorBuffer)
    
    Dim strName As String
    If Len(strErrorBuffer) > 0 Then
        strName = collaboration.displayName
        If Len(strName) = 0 Then
            strName = collaboration.owner.displayName
        End If
        MsgBox "The following issues were discovered while processing collaboration '" & strName & "':" & vbCrLf & strErrorBuffer
    End If
End Sub


Private Sub CopyMessages(ByRef collaboration As IRPCollaboration, ByRef strErrorBuffer As String)
    Dim message As IRPMessage
    Dim val As String
    
    For Each message In collaboration.messages
        ' message duration
        val = GetPropertyValue(message, "Local::SAAction.Message.RTduration")
        If Len(val) > 0 Then
            Call SetUMLTag(message, "RTtimeModeling", "RTaction", "RTduration", val)
        End If
        
        ' message interarrival time
        val = GetPropertyValue(message, "SATrigger.Message.SAOccurrencePattern")
        If Len(val) > 0 Then
            Call SetUMLTag(message, "RTschedulabilityModeling", "SATrigger", "SAoccurrence", val)
        End If
        
        If Not message.formalInterfaceItem Is Nothing Then
'            'duration
'            val = GetPropertyValue(message.formalInterfaceItem, "Local::SAAction.Event.RTduration")
'            If Len(val) = 0 Then
'                val = GetPropertyValue(message.formalInterfaceItem, "Local::SAAction.Operation.RTduration")
'            End If
'            If Len(val) = 0 Then
'                val = GetPropertyValue(message.formalInterfaceItem, "Local::SAAction.Class.RTduration")
'            End If
'            If Len(val) > 0 Then
'                Call SetUMLTag(message, "RTtimeModeling", "RTaction", "RTduration", val)
'            End If
'
            'interarrival time
            val = GetPropertyValue(message.formalInterfaceItem, "SATrigger.Event.SAOccurrencePattern")
            If Len(val) = 0 Then
                val = GetPropertyValue(message.formalInterfaceItem, "SATrigger.Class.SAOccurrencePattern")
            End If
            If Len(val) > 0 Then
                Call SetUMLTag(message, "RTschedulabilityModeling", "SATrigger", "SAoccurrence", val)
            End If
        End If
    Next
End Sub

'Private Sub CopyMessagesOld(ByRef collaboration As IRPCollaboration, ByRef strErrorBuffer As String)
'    Dim message As IRPMessage
'    Dim sourceLifeline As String
'    Dim val As String
'    Dim executingMessage As CExecutingMessage, parentExecutingMessage As CExecutingMessage
'    Dim executingMessageStack As New collection
'
'    'Set executingMessageStack = New collection
'    Set executingMessage = Nothing
'    For Each message In collaboration.messages
''        sourceLifeline = message.Source.name
'         If Not executingMessage Is Nothing Then
'            If message.Source.name = executingMessage.ExecutingLifeline Then
'                If Not executingMessage.UMLExecutionOccurrence Is Nothing Then
'                    message.sourceExecutionOccurrence = executingMessage.UMLExecutionOccurrence
'                End If
'                Call Push(executingMessageStack, executingMessage)
'            Else
'                Do
'                    ' update SPT on executing message's UML counterpart
'                    If (executingMessage.GetDuration() > 0# And executingMessage.UMLMessage.messageType <> "EVENT") Then
'                        Call SetUMLTag(executingMessage.UMLMessage, "RTAction", "RTduration", "{" + CStr(executingMessage.GetDuration()) + ",'ms'}")
'                    End If
'
'                    If Not IsStackEmpty(executingMessageStack) Then
'                        Set parentExecutingMessage = Pop(executingMessageStack)
'                        Call parentExecutingMessage.AddDuration(executingMessage.GetDuration())
'                        Set executingMessage = parentExecutingMessage
'                    Else
'                        Set executingMessage = Nothing
'                        Exit Do
'                    End If
'                Loop Until message.Source.name = executingMessage.ExecutingLifeline
'                If Not executingMessage Is Nothing Then
'                    Call Push(executingMessageStack, executingMessage)
'                End If
'            End If
'        End If
'        ' create new executing message
'        Set executingMessage = New CExecutingMessage
'        Set executingMessage.UMLMessage = message
'        ' if not reflexive, set executing lifeline
'        If message.target.name = message.Source.name Then
'            executingMessage.ExecutingLifeline = ""
'        Else
'            executingMessage.ExecutingLifeline = message.target.name
'        End If
'        If message.targetExecutionOccurrence Is Nothing Then
'            Set executingMessage.UMLExecutionOccurrence = message.addTargetExecutionOccurrence()
'        Else
'            Set executingMessage.UMLExecutionOccurrence = Nothing
'        End If
'
'        ' does it have a total RTduration?
''        val = GetPropertyValue(message, "SAAction.Message.RTduration")
''        If Len(val) > 0 Then
''            executingMessage.TotalDuration = ConvertTimeValueToUS(val)
''        Else
''            If (message.formalInterfaceItem Is Nothing) Then
''                strErrorBuffer = strErrorBuffer & "  Message '" & message.name & "' does not realize an operation in a class. No performance values from operations can be used." & vbCrLf
''            End If
''            val = GetPropertyValue(message.formalInterfaceItem, "SAAction.Event.RTduration")
''            If Len(val) > 0 Then
''                executingMessage.TotalDuration = ConvertTimeValueToUS(val)
''            Else
''                val = GetPropertyValue(message.formalInterfaceItem, "SAAction.Operation.RTduration")
''                If Len(val) > 0 Then
''                    executingMessage.TotalDuration = ConvertTimeValueToUS(val)
''                Else
''                    val = GetPropertyValue(message.formalInterfaceItem, "SAAction.Class.RTduration")
''                    If Len(val) > 0 Then
''                        executingMessage.TotalDuration = ConvertTimeValueToUS(val)
''                    End If
''                End If
''            End If
''        End If
'
'        ' local RTduration
'        val = GetPropertyValue(message, "Local::SAAction.Message.RTduration")
'        If Len(val) = 0 Then
'            val = GetPropertyValue(message.formalInterfaceItem, "Local::SAAction.Event.RTduration")
'        End If
'        If Len(val) = 0 Then
'            val = GetPropertyValue(message.formalInterfaceItem, "Local::SAAction.Operation.RTduration")
'        End If
'        If Len(val) = 0 Then
'            val = GetPropertyValue(message.formalInterfaceItem, "Local::SAAction.Class.RTduration")
'        End If
'        If Len(val) > 0 Then
'            executingMessage.LocalDuration = ConvertTimeValueToUS(val)
'            executingMessage.CalculatedDuration = executingMessage.LocalDuration
'        Else
'            executingMessage.LocalDuration = 0#
'            executingMessage.CalculatedDuration = 0#
'        End If
'
'        ' interarrival time
'        val = GetPropertyValue(message, "SATrigger.Message.SAOccurrencePattern")
'        If Len(val) = 0 Then
'            val = GetPropertyValue(message.formalInterfaceItem, "SATrigger.Event.SAOccurrencePattern")
'        End If
'        If Len(val) = 0 Then
'            val = GetPropertyValue(message.formalInterfaceItem, "SATrigger.Class.SAOccurrencePattern")
'        End If
'        If Len(val) > 0 Then
'            Call SetUMLTag(message, "SATrigger", "SAoccurrence", val)
'        End If
'    Next
'
'    If Not executingMessage Is Nothing Then
'        Do
'            If executingMessage.GetDuration() > 0# And executingMessage.UMLMessage.messageType <> "EVENT" Then
'                Call SetUMLTag(executingMessage.UMLMessage, "RTAction", "RTduration", "{" + CStr(executingMessage.GetDuration()) + ",'ms'}")
'            End If
'            If Not IsStackEmpty(executingMessageStack) Then
'                Set parentExecutingMessage = Pop(executingMessageStack)
'                Call parentExecutingMessage.AddDuration(executingMessage.GetDuration())
'                Set executingMessage = parentExecutingMessage
'            Else
'                Set executingMessage = Nothing
'                Exit Do
'            End If
'        Loop Until executingMessage Is Nothing
'    End If
'End Sub
